home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga Collections: Taifun
/
Taifun 099 (1989-05-15)(Ossowski, Stefan)(DE)(PD).zip
/
Taifun 099 (1989-05-15)(Ossowski, Stefan)(DE)(PD).adf
/
PCQ
/
Source
/
Stanprocs.p
< prev
next >
Wrap
Text File
|
1989-03-31
|
10KB
|
431 lines
external;
{
Stanprocs.p (of PCQ Pascal)
Copyright (c) 1989 Patrick Quaid
This routine implements the various standard procedures,
hence the name.
}
const
{$I "pasconst.i"}
type
{$I "pastype.i"}
var
{$I "pasvar.i"}
procedure nextsymbol;
forward;
function match(s : integer): boolean;
forward;
procedure error(s : string);
forward;
function expression(): integer;
forward;
function conexpr(var t : integer): integer;
forward;
function typecmp(t1, t2 : integer): boolean;
forward;
function typecheck(t1, t2 : integer): boolean;
forward;
function loadaddress() : integer;
forward;
procedure mismatch;
forward;
procedure needleftparent;
forward;
procedure needrightparent;
forward;
function findid(s : string) : integer;
forward;
procedure savestack(t : integer);
forward;
procedure saveval(v : integer);
forward;
procedure ns;
forward;
function loadvar(v : integer) : integer;
forward;
procedure promotetype(var f : integer; o, r : integer);
forward;
function numbertype(t : integer): boolean;
forward;
procedure callwrite(vartype : integer);
{
This routine calls the appropriate library routine to write
vartype to a text file.
}
var
elementtype : integer;
begin
if numbertype(vartype) then begin
promotetype(vartype, inttype, 0);
writeln(output, "\tjsr\t_p%writeint");
end else if typecmp(vartype, chartype) then
writeln(output, "\tjsr\t_p%writechar")
else if typecmp(vartype, booltype) then
writeln(output, "\tjsr\t_p%writebool")
else if idents[vartype].offset = varray then begin
elementtype := idents[vartype].vtype;
if typecmp(elementtype, chartype) then begin
writeln(output, "\tmove.l\t#",
idents[vartype].upper - idents[vartype].lower + 1, ',d3');
writeln(output, "\tjsr\t_p%writecharray");
end else
error("can only write arrays of char");
end else if typecmp(vartype, stringtype) then
writeln(output, "\tjsr\t_p%writestring")
else
error("can't write that type to text file");
end;
procedure filewrite(vartype : integer);
{
This routine writes a variable to a 'file of that
variable'.
}
begin
writeln(output, "\tmove.l\t#", idents[vartype].size, ',d3');
writeln(output, "\tjsr\t_p%writearb");
end;
procedure dowrite(varindex : integer);
{
This routine handles all aspects of the write and writeln
statements.
}
var
filetype : integer; { file type if there is one }
exprtype : integer; { current element type }
pushed : boolean; { have pushed the file handle on stack }
width : integer; { constant field width }
widtype : integer; { type of the above }
begin
if match(leftparent1) then begin
filetype := expression();
pushed := true;
if idents[filetype].offset = vfile then begin
writeln(output, "\tmove.l\td0,a0");
writeln(output, "\tmove.l\t(a0),d0");
writeln(output, "\tmove.l\td0,-(sp)");
end else begin
writeln(output, "\tmove.l\t_stdout,-(sp)");
if match(colon1) then begin
width := conexpr(widtype);
if not typecheck(inttype, widtype) then
error("Expecting integer value.");
writeln(output, "\tmove.w\t#", width, ',-(sp)');
end else
writeln(output, "\tmove.w\t#1,-(sp)");
callwrite(filetype);
writeln(output, "\taddq.l\t#2,sp");
filetype := texttype;
end;
while not match(rightparent1) do begin
if not match(comma1) then
error("expecting , or )");
exprtype := expression();
if typecmp(filetype, texttype) then begin
if match(colon1) then begin
width := conexpr(widtype);
if not typecheck(inttype, widtype) then
error("Expecting integer value.");
writeln(output, "\tmove.w\t#", width, ',-(sp)');
end else
writeln(output, "\tmove.w\t#1,-(sp)");
callwrite(exprtype);
writeln(output, "\taddq.l\t#2,sp");
end else begin
if typecmp(idents[filetype].vtype, exprtype) then
filewrite(exprtype)
else
mismatch;
end;
end;
end else begin
filetype := texttype;
pushed := false;
if idents[varindex].offset = 1 then
error("'write' requires arguments.");
end;
if idents[varindex].offset = 2 then begin
if filetype = texttype then begin
if pushed then
writeln(output, "\tjsr\t_p%writeln")
else begin
writeln(output, "\tmove.l\t_stdout,-(sp)");
writeln(output, "\tjsr\t_p%writeln");
writeln(output, "\taddq.l\t#4,sp");
end;
end else
error("No ...ln for non-text files");
end;
if pushed then
writeln(output, "\taddq.l\t#4,sp");
end;
procedure callread(vartype : integer);
{
This routine calls the appropriate library routines to read
the vartype from a text file.
}
begin
if typecmp(vartype, chartype) then
writeln(output, "\tjsr\t_p%readchar")
else if typecmp(vartype, inttype) then begin
writeln(output, "\tjsr\t_p%readint");
writeln(output, "\tmove.l\td0,(a0)");
end else if typecmp(vartype, shorttype) then begin
writeln(output, "\tjsr\t_p%readint");
writeln(output, "\tmove.w\td0,(a0)");
end else if idents[vartype].offset = varray then begin
if typecmp(idents[vartype].vtype, chartype) then begin
writeln(output, "\tmove.l\t#",
idents[vartype].upper - idents[vartype].lower + 1, ',d3');
writeln(output, "\tjsr\t_p%readcharray");
end else
error("can only read character arrays");
end else if typecmp(vartype, stringtype) then
writeln(output, "\tjsr\t_p%readstring");
else
error("cannot read that type from a text file");
end;
procedure doread(varindex : integer);
{
This handles the read statement. Note that read(f, var) from a
non-text file really does end up being var := f^; get(f). Same
goes for text files, but it's all handled within the library.
Note the difference between this and dowrite(),
specifically the use of expression() up there and loadaddress()
here.
}
var
filetype : integer;
vartype : integer;
pushed : boolean;
begin
if match(leftparent1) then begin
filetype := loadaddress();
pushed := true;
if idents[filetype].offset = vfile then
writeln(output, "\tmove.l\ta0,-(sp)");
else begin
writeln(output, "\tmove.l\t#0,-(sp)");
callread(filetype);
filetype := texttype;
end;
while not match(rightparent1) do begin
if not match(comma1) then
error("expecting , or )");
vartype := loadaddress();
if typecmp(filetype, texttype) then
callread(vartype)
else begin
if typecmp(idents[filetype].vtype, vartype) then
writeln(output, "\tjsr\t_p%readarb")
else
mismatch;
end;
end;
end else begin
filetype := texttype;
pushed := false;
if idents[varindex].offset = 3 then
error("'read' requires arguments.");
end;
if idents[varindex].offset = 4 then begin
if typecmp(filetype, texttype) then begin
if pushed then
writeln(output, "\tjsr\t_p%readln")
else begin
writeln(output, "\tmove.l\t#0,-(sp)");
writeln(output, "\tjsr\t_p%readln");
writeln(output, "\taddq.l\t#4,sp");
end;
end else
error("No ...ln for non-text files");
end;
if pushed then
writeln(output, "\taddq.l\t#4,sp");
end;
procedure donew;
{
This just handles allocation of memory.
}
var
varindex : integer;
vartype : integer;
varsize : integer;
stackvar : integer;
begin
needleftparent;
varindex := findid(symtext);
if varindex <> 0 then begin
stackvar := loadvar(varindex);
if stackvar <> 0 then begin
writeln(output, "\tmove.l\td0,-(sp)");
vartype := stackvar;
end else
vartype := idents[varindex].vtype;
if idents[vartype].offset <> vpointer then
error("expecting a pointer type");
varsize := idents[vartype].vtype;
varsize := idents[varsize].size;
writeln(output, "\tmove.l\t#", varsize, ',d0');
writeln(output, "\tjsr\t_p%new");
if stackvar <> 0 then
savestack(vartype)
else
saveval(varindex);
end else
error("Unknown identifier");
needrightparent;
end;
procedure dodispose;
{
This routine calls the library routine that disposes of
memory.
}
var
exprtype : integer;
begin
needleftparent;
exprtype := expression();
if idents[exprtype].offset <> vpointer then
error("Expecting a pointer type")
else
writeln(output, "\tjsr\t_p%dispose");
needrightparent;
end;
procedure doclose;
{
Closes a file. The difference between this and a normal
DOS close is that this routine must un-link the file from the
program's open file list.
}
var
exprtype : integer;
begin
needleftparent;
exprtype := expression();
if idents[exprtype].offset <> vfile then
error("Expecting a file type")
else
writeln(output, "\tjsr\t_p%close");
needrightparent;
end;
procedure doget;
{
This implements get. There is no analogous put(), since
the write statements never needed it.
}
var
exprtype : integer;
begin
needleftparent;
exprtype := expression();
if idents[exprtype].offset <> vfile then
error("Expecting a file type")
else begin
writeln(output, "\tmove.l\td0,a0");
writeln(output, "\tjsr\t_p%readarbbuf");
end;
needrightparent;
end;
procedure doexit;
{
Just calls the routine that allows the graceful shut-down
of the program.
}
var
exprtype : integer;
begin
needleftparent;
exprtype := expression();
if not typecheck(exprtype, inttype) then
error("Expecting an integer argument.");
writeln(output, "\tjsr\t_p%exit");
needrightparent;
end;
procedure dotrap;
{
This is just for debugging a program. Use some trap, and
your debugger will stop at that statement.
}
var
exprtype,
trapnum : integer;
begin
needleftparent;
trapnum := conexpr(exprtype);
writeln(output, "\ttrap\t#", trapnum);
needrightparent;
end;
procedure stdproc(varindex : integer);
{
This routine sifts out the proper routine to call.
}
var
exprtype : integer;
pushed : boolean;
begin
nextsymbol;
pushed := false;
if (idents[varindex].offset = 1) or
(idents[varindex].offset = 2) then
dowrite(varindex)
else if (idents[varindex].offset = 3) or
(idents[varindex].offset = 4) then
doread(varindex)
else if idents[varindex].offset = 5 then
donew
else if idents[varindex].offset = 6 then
dodispose
else if idents[varindex].offset = 7 then
doclose
else if idents[varindex].offset = 8 then
doget
else if idents[varindex].offset = 9 then
doexit
else if idents[varindex].offset = 10 then
dotrap;
ns;
end;